VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsWordMerge"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'**(CLASS HEADER)*************************************************
'*
'*   Author:  Tmess  EMail: MessinaThomas@Hotmail.com
'*  Purpose:  1.Create New word Document
'*            2.Set the pagesetup and Add text to the document
'*            3.Position and format the text
'*            4.Insert data from a database into the table
'*            5.Save the document
'*            6.Create a new e-mail using outlook
'*            7.Insert the document into an e-mail
'*            8.Send the e-mail
'*            9.Delete the document
'*            10.All errors are logged in a textfile and can be raised in the form
'*
'*  You can use all the above or some
'*
'*  Use this at your own risk. I am not responsible for misuse of this class
'*   Please improve if you want. Let me know
'*
'******************************************************************

Public Enum PageSetups
   Landscape = wdOrientLandscape
   Portrait = wdOrientPortrait
End Enum

Public Enum Alignment
    Center = WdParagraphAlignment.wdAlignParagraphCenter
    Left = WdParagraphAlignment.wdAlignParagraphLeft
    Right = WdParagraphAlignment.wdAlignParagraphRight
    Justify = WdParagraphAlignment.wdAlignParagraphJustify
End Enum

Private m_ProcedureName As String 'Name of current procedure: for error handling
Private m_dbPathName As String 'Path and name of Database
Private m_IsConnected As Boolean 'Is there a connection to database
Private m_NumOfLines As Integer 'Number of blank lines to insert
Private m_StrHyperlink As String 'Name of hyperlink
Private m_Strsubject As String 'Subject of E-mail message
Private m_StrTo As String 'Recipient address
Private m_StrToAdd As String 'Text to add to Word doc
Private m_VarMsgBody As Variant 'Body of e-mail message
Private m_FontSize As Integer 'Font size of StrToAdd
Private m_FontBold As Boolean 'Is strToAdd bold or Not
Private m_ParaAlign As Integer 'StrToAdd alignment SEE ENUM ALIGNMENT
Private m_PageSetup As Integer 'Page setup of Word Doc SEE ENUM PAGESETUPS
Private m_Database As Dao.Database 'DAO database object
Private m_Recordset As Dao.Recordset 'DAO Recordset object
Private m_sql As String 'SQL String passed from client
Private i As Integer 'Used in for next loop

Private wrdApp As Word.Application 'MS Word object
Private wrdDoc As Word.Document 'MS Word Document
Private wrdSelection As Word.Selection 'MS Word Selection
Private strDocName As String 'MS Word document name

'Raised if merge successful
Public Event MergeComplete()
'Raised if merge Unsuccessful
Public Event MergeFailed(errNum As Integer, msgWhy As String)
'Raised if merge document saved successfully
Public Event DocumentSaved()
'Raised if merge document saved Unsuccessfully
Public Event DocumentNotSaved(errNum As Integer, msgWhy As String)
'Raised if document was e-mailed successfully
Public Event MessageSent()
'Raised if document was e-mailed Unsuccessfully
Public Event MessageNotSent(errNum As Integer, msgWhy As String)
'Raised if database connection was successful
Public Event ConnectionSuccessful()
'Raised if database connection was Unsuccessful
Public Event ConnectionNotSuccessful(errNum As Integer, msgWhy As String)
'Raise for unknown errors
Public Event UnknownError(errNum As Integer, msgWhy As String)

Private Sub Class_Initialize()

    Set wrdApp = New Word.Application
    
    'Set to false if you don't want to see the word doc
    wrdApp.Visible = True
    'Database connection has not been established yet
    m_IsConnected = False
End Sub


Private Sub Class_Terminate()

    wrdApp.Quit
    Set wrdSelection = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing

End Sub
Public Sub OpenNewDoc()

    Set wrdDoc = wrdApp.Documents.Add
    wrdDoc.Select
    
    Set wrdSelection = wrdApp.Selection
    
End Sub

Public Property Let PageSetupDocument(IntPageSetup As Integer)

    m_PageSetup = IntPageSetup
    wrdDoc.PageSetup.Orientation = m_PageSetup
    
End Property

Public Sub DatabaseToConnect(dbPathAndName As String)
On Error GoTo Err_Handler

    'Check to see if a connection to a database is already opened
    If m_IsConnected Then
        MsgBox "Connection already established. Close the current " & _
         "connection first before opening a new database", vbInformation, _
         "Connection Already Established"
        Exit Sub
    End If
    
    m_dbPathName = dbPathAndName
    
    'Check to see if the path and the database exists
    If FileExist(m_dbPathName) = False Then
     MsgBox "File Not Found. Could not Establish Connection", vbCritical, _
            "File Not Found"
        Exit Sub
    End If
    
    Set m_Database = DBEngine.OpenDatabase(m_dbPathName)
    m_IsConnected = True
    
Exit Sub
    
Err_Handler:
        m_ProcedureName = "DatabaseToConnect"
        Call ClsErrorHandler
        
End Sub
Public Sub DatabaseDisConnect()
    'Close and Release database object from memory
    If m_IsConnected Then
        m_Database.Close
        Set m_Database = Nothing
        m_IsConnected = False
        Exit Sub
    End If
    
End Sub

Public Property Let InsertLinesInDoc(numOfLines As Integer)

    m_NumOfLines = numOfLines
    InsertLines m_NumOfLines
    
End Property

Public Sub InsertText(strToAdd As String, IntFontSize As Integer, _
    blBold As Boolean, intParagraphAlign As Integer)

    m_StrToAdd = strToAdd
    m_FontBold = blBold
    m_FontSize = IntFontSize
    m_ParaAlign = intParagraphAlign
    
    InsertTextIntoDoc
    
End Sub

Public Property Let InsertHyperlinkAddress(strHyperlink As String)

    m_StrHyperlink = strHyperlink
    InsertHyperlink
    
End Property

Public Sub InsertTableWithData(strRecordSet As String, _
        Optional RecordSetToUse As Dao.Recordset)
On Error GoTo Error_Handler
        
 Dim intNumofRows As Integer
 Dim intNumofColumns As Integer
 Dim p As Integer, ColWidth As Integer

    'Check to see if a new connection to the database
     'has been established
    If m_IsConnected Then
        m_sql = strRecordSet
        Set m_Recordset = m_Database.OpenRecordset(m_sql)
    Else
        Set m_Recordset = RecordSetToUse
    End If
 
    m_Recordset.MoveLast
    m_Recordset.MoveFirst

    intNumofColumns = m_Recordset.Fields.Count
    intNumofRows = m_Recordset.RecordCount
 
    'Insert a new table with rows according to recordCount plus Column header
    'and the number of columns in the recordset
     
    wrdDoc.Tables.Add wrdSelection.Range, NumRows:=intNumofRows + 1, _
    NumColumns:=intNumofColumns
    
    With wrdDoc.Tables(1)
    ' Set the column widths
     For i = 0 To intNumofColumns - 1
     ColWidth = Len(m_Recordset.Fields(i).Name)
        .Columns(i + 1).SetWidth ColWidth * 25, wdAdjustNone
        .Cell(1, i + 1).Range.InsertAfter UCase(m_Recordset.Fields(i).Name)
     Next i
        
        ' Set the shading on the first row to light gray
        .Rows(1).Cells.Shading.BackgroundPatternColorIndex = wdGray25
        
        ' Bold the first row
        .Rows(1).Range.Bold = True
        
        ' Center the text in Cell (1,1)
        .Cell(1, 1).Range.Paragraphs.Alignment = wdAlignParagraphCenter
        
        ' Fill each row of the table with data
        For i = 1 To intNumofRows
         For p = 1 To intNumofColumns
          FillRow i + 1, p, m_Recordset.Fields(p - 1)
         Next p
         p = 1
         m_Recordset.MoveNext
        Next i
    End With
    
    RaiseEvent MergeComplete
    
Exit_Handler:

   'release objects from memory
   If m_IsConnected Then
    m_Recordset.Close
   End If
   
   Set m_Recordset = Nothing
  Exit Sub
    
Error_Handler:
    m_ProcedureName = "InsertTableWithData"
    Call ClsErrorHandler
    Resume Exit_Handler
        
End Sub
Private Sub InsertHyperlink()
    'Inserts a hyperlink

    wrdSelection.Hyperlinks.Add Anchor:=wrdSelection.Range, _
    Address:=m_StrHyperlink
    
End Sub

Private Sub InsertTextIntoDoc()
    'This routines insert text into the word document and sets the font
    'and alignment

    wrdSelection.ParagraphFormat.Alignment = m_ParaAlign
    wrdSelection.Font.Size = m_FontSize
    wrdSelection.Font.Bold = m_FontBold
    wrdSelection.TypeText m_StrToAdd
    
End Sub
Private Sub InsertLines(LineNum As Integer)
    Dim iCount As Integer
    'Insert blank lines in Word document
    For iCount = 1 To LineNum
        wrdApp.Selection.TypeParagraph
    Next iCount
End Sub
   
Private Sub FillRow(Row As Integer, Column, _
                   Text1 As String)
' Insert the data into the specific cell
                   
    With wrdDoc.Tables(1)
        .Cell(Row, Column).Range.InsertAfter Text1
    End With
    
End Sub
Public Sub printDoc()
    'print out the word doc
    wrdDoc.PrintOut
    
End Sub
Public Sub SendDoc(ByVal strTo As String, ByVal strSubject As String, _
    varMsgBody As Variant)

On Error GoTo OutLookTrap
    'Mail the word document to recipient specified

Dim ObjOutlook As Outlook.Application
Dim ObjMailItem As Outlook.MailItem

        
    m_Strsubject = strSubject
    m_StrTo = strTo
    m_VarMsgBody = varMsgBody

    'Check to see if the e-mail address is correct by checking the format
    If checkEmailAddress = False Then
     m_ProcedureName = "SendDoc"
     Call ClsErrorHandler
     Exit Sub
    End If
    
        Set ObjOutlook = New Outlook.Application
        Set ObjMailItem = ObjOutlook.CreateItem(olMailItem)
        
    'create e-mail and insert attachment
        With ObjMailItem
            .Recipients.Add m_StrTo
            .Subject = m_Strsubject
            .Body = m_VarMsgBody & vbCrLf & vbCrLf
            .Attachments.Add strDocName
        End With
        
        ObjMailItem.Send
        RaiseEvent MessageSent
        
OutLookTrapExit:
        Set ObjMailItem = Nothing
        Set ObjOutlook = Nothing
        Exit Sub
OutLookTrap:
        m_ProcedureName = "SendDoc"
        Resume OutLookTrapExit
End Sub
Public Sub SaveDocAsAndClose(Path As String, StrToSaveAs As String)
On Error GoTo Err_Handler
    'Check to see if the path exists
    If DriveExist(Path) = False Then Exit Sub
    
    ' Save the document, close it
    strDocName = Path & StrToSaveAs & ".doc"
    wrdDoc.SaveAs strDocName
    wrdDoc.Close
    
    RaiseEvent DocumentSaved
    
Exit_Err_Handler:
   Exit Sub
    
Err_Handler:
    m_ProcedureName = "SaveDocAsAndClose"
    Resume Exit_Err_Handler
    
End Sub

Public Sub DeleteDoc(PathAndDocName As String)
   'Delete a file
   If FileExist(PathAndDocName) Then
    Kill PathAndDocName
   End If
       
End Sub
Public Sub InsertCurrentDate()
    'Inserts the current date with the deafult font

    wrdSelection.InsertDateTime _
    DateTimeFormat:="dddd, MMMM dd, yyyy", InsertAsField:=False
    
End Sub

Private Function checkEmailAddress() As Boolean
On Error Resume Next
    'parses e-mail address to see if is correct
    i = InStr(m_StrTo, "@")
    checkEmailAddress = (InStr(i + 1, m_StrTo, ".") > 0)
   
End Function

Private Function FileExist(filename As String) As Boolean
On Error Resume Next

    FileExist = (Dir$(UCase((filename))) <> "")

End Function

Private Function DriveExist(Path As String) As Boolean
On Error Resume Next

    DriveExist = (Dir(UCase((Path))) <> "")

End Function

Private Sub ClsErrorHandler()
    'Generic Error handling routine

Dim handleErr As String
Dim textfile As String

    'Raise the event according the procedure passed. Will write all errors
     'to an error log. Errors on the form will only be visible if
     'the event is active and a debug.print statement or message box
     'is inserted
    
Select Case m_ProcedureName

    Case Is = "SaveDocAsAndClose"
        RaiseEvent DocumentNotSaved(Err.Number, Err.Description)
        
    Case Is = "SendDoc"
        RaiseEvent MessageNotSent(Err.Number, Err.Description)
        
    Case Is = "InsertTableWithData"
        RaiseEvent MergeFailed(Err.Number, Err.Description)
        
    Case Is = "DatabaseToConnect"
        RaiseEvent ConnectionNotSuccessful(Err.Number, Err.Description)
        
    Case Else
        RaiseEvent UnknownError(Err.Number, Err.Description)
        
End Select

    'Log the errors to an error log
    textfile = App.Path & "\ErrogLog.txt"
    handleErr = "Error: " & Err.Number & " " & Err.Description & _
                 " " & Err.Source

    Open textfile For Append As #1 'write error to textfile
        Write #1, Now; handleErr; m_ProcedureName
    Close #1

    Err.Clear

End Sub

